home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGSCAL
/
TINYPASC.LZH
/
TUDBUG.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-02-17
|
5KB
|
202 lines
{ TUDBUG: Skeleton file debugging routines. }
{ Copyright (C) 1986 by QCAD Systems Inc., All Rights Reserved. }
{******************}
procedure WRSYMBOL(var SYM: symbol);
{ write out a symbol name. }
begin
write(rfile, sym);
end;
{******************}
function WRTOK(TX: int): int;
{ writes the print name of the TX'th token, returning
the number of characters output. }
var TL: int;
begin
tx := tokx[tx];
tl := 0;
while tokchar[tx] <> chr(0) do begin
write(rfile, tokchar[tx]);
tx := tx+1;
tl := tl+1
end;
wrtok := tl;
end;
{****************}
procedure WRPROD(PRX: int);
{ write out the PRX'th production (a series of tokens). }
var TL: int;
begin
prx := prodx[prx];
tl := wrtok(prods[prx]);
write(rfile, ' ->');
prx := prx+1;
while prods[prx]<>0 do begin
write(rfile, ' ');
tl := wrtok(prods[prx]);
prx := prx+1;
end
end;
{******************}
procedure DUMP_SYM(INDENT: int; SYMP: symtabp;
NTAG: string31);
{ output information on the given symbol table entry. this can
be extended to handle user-defined symbol types (e.g. functions
and variables). }
begin
if symp<>nil then
with symp^ do begin
writeln(rfile);
write(rfile, ' ':indent, ntag, ': ');
wrsymbol(sym);
write(rfile, ' (', sym_names[symt], ')');
case symt of
var_type: write(rfile, ' VADDR=', vaddr:1);
func_type:
write(rfile, ' FADDR=', faddr:1, ' PBYTES=', pbytes:1,
' IS_ACTUAL=', is_actual,
' IS_SYSTEM=', is_system);
ELSE ;
end
end
end;
{*****************}
procedure DUMP_SEM(INDENT: int; SEMSTK: semrecp;
NTAG: string31);
{ output a semantic stack record. }
begin
if semstk<>nil then
with semstk^ do begin
writeln(rfile);
write(rfile, ' ':indent);
write(rfile, sem_names[semt], ': ');
case semt of
other: ;
ident: dump_sym(indent+2, symp, 'symp');
fixed: write(rfile, numval:1);
ELSE write(rfile, ' ... user form')
end
end
end;
{*********************}
procedure STK_DUMP(KIND: string8; var STACK: state_stack;
STACKX: int; CSTATE: int);
{ produce a symbolic dump of the parser stack. }
var SX, TL, LL: int;
begin
if debug>2 then begin
write(rfile, kind {, ', state ', cstate:1} );
if cstate>=readstate then begin
write(rfile, ', on token ');
tl := wrtok(token);
end;
writeln(rfile, ', memavail ', memavail:1);
end;
if cstate<readstate then begin
{ reduce state }
if debug>1 then begin {complete stack dump}
if tos>15 then begin
writeln(rfile, ' ###');
sx := tos-15;
end
else
sx := 1;
while sx<=tos do begin
tl:=0;
write(rfile, tos-sx:3, ': ');
tl:=tl+5;
{write(rfile, stack[sx]:3, ' ');
tl:=tl+4; }
if sx=tos then
tl := tl+wrtok(insym[cstate])
else
tl := tl+wrtok(insym[stack[sx+1]]);
dump_sem(6, sem[sx], '');
writeln(rfile);
sx:=sx+1;
end
end;
wrprod(cstate);
writeln(rfile)
end;
{ don't let this roll off the top of the screen }
idebug
end;
{****************}
procedure IDEBUG;
{ interactive debugging support }
var QUIT: boolean;
{..................}
procedure SHOW_SYM;
label 1;
{ asks for a symbol, then dumps the symbol table entry for it }
var SP: symtabp;
LINE: string80;
SX: integer;
begin
1:
write('What symbol? ');
readln(line);
if length(line)>sizeof(symbol) then goto 1;
sp := findsym(symtab, line);
if sp<>nil then
dump_sym(0, sp, '')
else
writeln('Unknown symbol');
writeln;
end;
{.................}
procedure DUMP_ALL;
{ show everything in the symbol table }
var HX: int;
SP: symtabp;
begin
for hx := 0 to hlimit do begin
sp := symtab[hx];
while sp<>nil do begin
with sp^ do begin
if not (symt in [reserved, symerr]) then begin
{ report only the nontrivial stuff }
wrsymbol(sym);
write(rfile, ' ');
end;
sp := next
end
end
end;
writeln(rfile);
end;
{................}
procedure SET_DEBUG;
{ prompts for a debug level number }
begin
write('Set debug level to (0, 1, ...)? ');
readln(debug);
end;
begin { idebug }
quit := false;
while not quit do begin
writeln('Trace is ', trace);
case upcase(resp(
'I(dentifier, D(ebug level, A(ll symbols, T(race, C(ontinue? ')) of
'I': show_sym;
'A': dump_all;
'D': set_debug;
'C': quit := true;
'T': trace := not(trace);
ELSE ;
end
end
end { idebug };